home *** CD-ROM | disk | FTP | other *** search
- VERSION 2.00
- Begin Form fTblStru
- BackColor = &H00C0C0C0&
- Caption = "Table Structure"
- ClientHeight = 5550
- ClientLeft = 2100
- ClientTop = 1890
- ClientWidth = 5040
- Height = 5955
- Icon = 0
- Left = 2040
- LinkTopic = "Form1"
- MaxButton = 0 'False
- MinButton = 0 'False
- ScaleHeight = 5550
- ScaleWidth = 5040
- Top = 1545
- Width = 5160
- Begin TextBox cTableName
- BackColor = &H00FFFFFF&
- Height = 288
- Left = 1680
- TabIndex = 0
- Tag = "OLS"
- Top = 120
- Width = 1932
- End
- Begin PictureBox IndexBox
- BackColor = &H00C0C0C0&
- BorderStyle = 0 'None
- Height = 1692
- Left = 0
- ScaleHeight = 1695
- ScaleWidth = 5055
- TabIndex = 9
- Top = 3720
- Width = 5052
- Begin CommandButton PrintButton
- Caption = "&Print Structure"
- Height = 372
- Left = 720
- TabIndex = 14
- Top = 1320
- Visible = 0 'False
- Width = 1452
- End
- Begin CommandButton AddTableButton
- Caption = "&Build the Table"
- Enabled = 0 'False
- Height = 372
- Left = 720
- TabIndex = 8
- Top = 1320
- Visible = 0 'False
- Width = 1452
- End
- Begin CommandButton CloseButton
- Cancel = -1 'True
- Caption = "&Close"
- Height = 372
- Left = 2880
- TabIndex = 3
- Top = 1320
- Width = 1452
- End
- Begin CommandButton AddIndexButton
- Caption = "Add &Index"
- Height = 252
- Left = 1200
- TabIndex = 5
- Top = 120
- Width = 1332
- End
- Begin CommandButton DelIndexButton
- Caption = "&Delete Index"
- Height = 252
- Left = 2640
- TabIndex = 6
- Top = 120
- Width = 1332
- End
- Begin Grid cIndexes
- Cols = 4
- FixedCols = 0
- Height = 750
- Left = 120
- TabIndex = 2
- Top = 420
- Width = 4815
- End
- Begin Line Line1
- BorderWidth = 5
- X1 = 0
- X2 = 4800
- Y1 = 0
- Y2 = 0
- End
- Begin Label IndexesLabel
- BackColor = &H00C0C0C0&
- Caption = "Indexes:"
- Height = 252
- Left = 240
- TabIndex = 10
- Top = 120
- Width = 1092
- End
- End
- Begin PictureBox FieldBox
- BackColor = &H00C0C0C0&
- BorderStyle = 0 'None
- Height = 2892
- Left = 0
- ScaleHeight = 2895
- ScaleWidth = 5055
- TabIndex = 11
- Top = 600
- Width = 5052
- Begin CommandButton RemoveFieldButton
- Caption = "&Remove Field"
- Height = 252
- Left = 2625
- TabIndex = 7
- Top = 0
- Width = 1332
- End
- Begin CommandButton AddFieldButton
- Caption = "&Add Field"
- Height = 252
- Left = 1200
- TabIndex = 4
- Top = 0
- Width = 1332
- End
- Begin Grid cFields
- BackColor = &H00FFFFFF&
- Cols = 3
- FixedCols = 0
- Height = 2532
- Left = 120
- TabIndex = 1
- Top = 288
- Width = 4800
- End
- Begin Label FieldsLabel
- BackColor = &H00C0C0C0&
- Caption = "Fields:"
- Height = 192
- Left = 240
- TabIndex = 12
- Top = 0
- Width = 732
- End
- End
- Begin Label TableNameLabel
- BackColor = &H00C0C0C0&
- Caption = "Table Name:"
- Height = 252
- Left = 360
- TabIndex = 13
- Top = 120
- Width = 1212
- End
- Option Explicit
- Sub AddFieldButton_Click ()
- MsgBar "Enter New Field Parameters, Press 'Close' when finished", False
- fAddField.Show MODAL
- MsgBar NULL_STR, False
- End Sub
- Sub AddIndexButton_Click ()
- MsgBar "Enter New Index Parameters, Press 'Close' when finished", False
- fIndexAdd.Show MODAL
- MsgBar NULL_STR, False
- End Sub
- Sub AddTableButton_Click ()
- Dim tbl As New TableDef
- Dim fld As Field
- Dim ind As Index
- Dim i As Integer
- Dim x As String
- On Error GoTo ATErr
- SetHourglass Me
- MsgBar "Building New Table", True
- tbl.Name = cTableName
- 'search to see if table exists
- For i = 0 To gCurrentDB.TableDefs.Count - 1
- If UCase(gCurrentDB.TableDefs(i).Name) = UCase(tbl.Name) Then
- If MsgBox(tbl.Name & " already exists, delete it?", 4) = YES Then
- gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(tbl.Name)
- Else
- ResetMouse Me
- Exit Sub
- End If
- Exit For
- End If
- Next
- 'add the first field
- cFields.Row = 1
- cFields.Col = 0
- If Len(cFields) = 0 Then
- Beep
- MsgBox "No Fields Defined!", 48
- Exit Sub
- End If
- Set fld = New Field
- fld.Name = cFields
- cFields.Col = 1
- fld.Type = GetFieldType((cFields))
- If cFields = "Counter" Then
- fld.Attributes = &H10 'counter type
- End If
- cFields.Col = 2
- fld.Size = Val(cFields)
- tbl.Fields.Append fld
- gCurrentDB.TableDefs.Append tbl
- 'add the rest of the fields
- For i = 2 To cFields.Rows - 1
- Set fld = New Field
- cFields.Row = i
- cFields.Col = 0
- fld.Name = cFields
- cFields.Col = 1
- fld.Type = GetFieldType((cFields))
- If cFields = "Counter" Then
- fld.Attributes = &H10 'counter type
- End If
- cFields.Col = 2
- fld.Size = Val(cFields)
- gCurrentDB.TableDefs(tbl.Name).Fields.Append fld
- Next
- 'add the indexes
- For i = 1 To cIndexes.Rows - 1
- Set ind = New Index
- cIndexes.Row = i
- cIndexes.Col = 0
- If Len(cIndexes) = 0 Then Exit For
- ind.Name = cIndexes
- cIndexes.Col = 1
- ind.Fields = cIndexes
- cIndexes.Col = 2
- If cIndexes = "True" Then
- ind.Unique = True
- Else
- ind.Unique = False
- End If
- cIndexes.Col = 3
- If gstDataType = SQLDB Then
- cIndexes = "N/A"
- Else
- If cIndexes = "True" Then
- ind.Primary = True
- Else
- ind.Primary = False
- End If
- End If
- gCurrentDB.TableDefs(tbl.Name).Indexes.Append ind
- Next
- RefreshTables fTables.cTableList, True
- GoTo ATEnd
- ATErr:
- ResetMouse Me
- ShowError
- Exit Sub
- ATEnd:
- ResetMouse Me
- MsgBar NULL_STR, False
- Unload Me
- End Sub
- Sub cFields_DblClick ()
- Dim f As New fDataBox
- Dim erm As String
- 'only allowed on existing tables
- If gfAddTableFlag = True Then
- Exit Sub
- End If
- On Error GoTo FldPropErr
- cFields.Row = cFields.SelStartRow
- cFields.Col = 0
- Set gCurrentField = gCurrentDB.TableDefs(fTables.cTableList).Fields(cFields)
- f.caption = "Field Properties"
- f.Tag = "FLD"
- erm = "Name"
- f.cData.AddItem "Name = " & gCurrentField.Name
- erm = "Type"
- f.cData.AddItem "Type = " & gCurrentField.Type
- erm = "Size"
- f.cData.AddItem "Size = " & gCurrentField.Size
- erm = "SourceField"
- f.cData.AddItem "SourceField = " & gCurrentField.SourceField
- erm = "SourceTable"
- f.cData.AddItem "SourceTable = " & gCurrentField.SourceTable
- erm = "CollatingOrder"
- f.cData.AddItem "CollatingOrder = " & gCurrentField.CollatingOrder
- erm = "Attributes"
- f.cData.AddItem "Attributes = &H" & Hex(gCurrentField.Attributes)
- erm = "OrdinalPosition"
- f.cData.AddItem "OrdinalPosition = " & gCurrentField.OrdinalPosition
- f.Show MODAL
- GoTo FldPropEnd
- FldPropErr:
- f.cData.AddItem erm & ":" & Error$
- Resume Next
- FldPropEnd:
- End Sub
- Sub cIndexes_DblClick ()
- Dim f As New fDataBox
- Dim erm As String
- 'only allowed on existing tables
- If gfAddTableFlag = True Then
- Exit Sub
- End If
- On Error GoTo IndPropErr
- cIndexes.Row = cIndexes.SelStartRow
- cIndexes.Col = 0
- Set gCurrentIndex = gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes)
- f.caption = "Field Properties"
- f.Tag = "IND"
- erm = "Name"
- f.cData.AddItem "Name = " & gCurrentIndex.Name
- erm = "Fields"
- f.cData.AddItem "Fields = " & gCurrentIndex.Fields
- erm = "Unique"
- f.cData.AddItem "Unique Flag = " & stTrueFalse((gCurrentIndex.Unique))
- erm = "Primary"
- f.cData.AddItem "PrimaryFlag = " & stTrueFalse((gCurrentIndex.Primary))
- f.Show MODAL
- GoTo IndPropEnd
- IndPropErr:
- f.cData.AddItem erm & ":" & Error$
- Resume Next
- IndPropEnd:
- End Sub
- Sub CloseButton_Click ()
- Unload Me
- MsgBar NULL_STR, False
- End Sub
- Sub cTableName_Change ()
- If Len(cTableName) = 0 Then
- AddTableButton.Enabled = False
- Else
- AddTableButton.Enabled = True
- End If
- End Sub
- Sub cTableName_KeyPress (KeyAscii As Integer)
- If cTableName.TabStop = False Then
- KeyAscii = 0 'throw away the key
- End If
- End Sub
- Sub DelIndexButton_Click ()
- On Error GoTo DELErr
- cIndexes.Row = cIndexes.SelStartRow
- cIndexes.Col = 0
- If Len(cIndexes) = 0 Then Exit Sub
- If MsgBox("Delete """ & cIndexes & """ index?", MSGBOX_TYPE) = YES Then
- If gfAddTableFlag = False Then
- gCurrentDB.TableDefs(fTables.cTableList).Indexes.Delete gCurrentDB.TableDefs(fTables.cTableList).Indexes(cIndexes)
- End If
- 'refresh the list of indexes
- If cIndexes.Rows = 2 Then
- cIndexes.Col = 0
- cIndexes = NULL_STR
- cIndexes.Col = 1
- cIndexes = NULL_STR
- cIndexes.Col = 2
- cIndexes = NULL_STR
- Else
- cIndexes.RemoveItem cIndexes.Row
- End If
- End If
- Exit Sub
- DELErr:
- ShowError
- Exit Sub
- End Sub
- Sub Form_Load ()
- Dim tbl As TableDef
- Dim i As Integer
- Dim s As String
- On Error GoTo LoadErr
- Width = 5160
- Height = 5955
- SetHourglass Me
- fTables.MousePointer = HOURGLASS
- MsgBar "Opening Design Form", True
- fTblStru.cTableName.TabStop = gfAddTableFlag
- 'setup field grid titles
- cFields.ColWidth(0) = 2500
- cFields.ColWidth(1) = 1500
- cFields.ColWidth(2) = 500
- cFields.Row = 0
- cFields.Col = 0
- cFields = "Name"
- cFields.Col = 1
- cFields = "Type"
- cFields.Col = 2
- cFields = "Size"
- 'setup index grid titles
- cIndexes.ColWidth(0) = 850
- cIndexes.ColWidth(1) = 2250
- cIndexes.ColWidth(2) = 650
- cIndexes.ColWidth(3) = 700
- cIndexes.Row = 0
- cIndexes.Col = 0
- cIndexes = "Name"
- cIndexes.Col = 1
- cIndexes = "Indexed Fields"
- cIndexes.Col = 2
- cIndexes = "Unique"
- cIndexes.Col = 3
- cIndexes = "Primary"
- If gfAddTableFlag = True Then
- caption = "Add Table"
- AddTableButton.Visible = True
- cFields.Rows = 2
- cIndexes.Rows = 2
- Else
- caption = "View/Modify Structure"
- PrintButton.Visible = True
- RemoveFieldButton.Visible = False
- fTblStru.cTableName = fTables.cTableList
- Set tbl = gCurrentDB.TableDefs(fTables.cTableList)
- cFields.Rows = tbl.Fields.Count + 1
- For i = 1 To cFields.Rows - 1
- cFields.Row = i
- cFields.Col = 0
- cFields = tbl.Fields(i - 1).Name
- cFields.Col = 1
- Select Case tbl.Fields(i - 1).Type
- Case FT_TRUEFALSE
- s = "True/False"
- Case FT_BYTE
- s = "Byte"
- Case FT_INTEGER
- s = "Integer"
- Case FT_LONG
- If tbl.Fields(i - 1).Attributes And &H10 = &H10 Then
- s = "Counter"
- Else
- s = "Long"
- End If
- Case FT_CURRENCY
- s = "Currency"
- Case FT_SINGLE
- s = "Single"
- Case FT_DOUBLE
- s = "Double"
- Case FT_DATETIME
- s = "Date/Time"
- Case 9
- s = "Reserved/9"
- Case FT_STRING
- s = "String"
- Case FT_BINARY
- s = "Binary"
- Case FT_MEMO
- s = "Memo"
- Case Else
- s = CStr(tbl.Fields(i - 1).Type)
- End Select
- cFields = s
- cFields.Col = 2
- cFields = CStr(tbl.Fields(i - 1).Size)
- Next
- If tbl.Indexes.Count = 0 Then
- cIndexes.Rows = 2
- Else
- cIndexes.Rows = tbl.Indexes.Count + 1
- For i = 1 To cIndexes.Rows - 1
- cIndexes.Row = i
- cIndexes.Col = 0
- cIndexes = tbl.Indexes(i - 1).Name
- cIndexes.Col = 1
- cIndexes = tbl.Indexes(i - 1).Fields
- cIndexes.Col = 2
- If tbl.Indexes(i - 1).Unique = False Then
- s = "False"
- Else
- s = "True"
- End If
- cIndexes = s
- cIndexes.Col = 3
- If gstDataType = SQLDB Then
- s = "N/A"
- Else
- If tbl.Indexes(i - 1).Primary = False Then
- s = "False"
- Else
- s = "True"
- End If
- End If
- cIndexes = s
- Next
- End If
- End If
- 'lock the titles row and set the selected cell
- cFields.Row = 1
- cFields.SelStartCol = 0
- cFields.SelEndCol = 0
- cFields.FixedRows = 1
- cIndexes.Row = 1
- cIndexes.SelStartCol = 0
- cIndexes.SelEndCol = 0
- cIndexes.FixedRows = 1
- ResizeFieldGrid
- GoTo LoadEnd
- LoadErr:
- ResetMouse Me
- fTables.MousePointer = DEFAULT_MOUSE
- ShowError
- Unload Me
- MsgBar NULL_STR, False
- Exit Sub
- Resume LoadEnd
- LoadEnd:
- ResetMouse Me
- fTables.MousePointer = DEFAULT_MOUSE
- MsgBar NULL_STR, False
-
- End Sub
- Sub Form_Paint ()
- Outlines Me
- FieldBox.Refresh
- PicOutlines FieldBox, cFields
- IndexBox.Refresh
- PicOutlines IndexBox, cIndexes
- End Sub
- Sub Form_Resize ()
- On Error Resume Next
- If WindowState <> 1 Then
- If Width < 5190 Then
- Width = 5190
- End If
- FieldBox.Width = Width ' - 350
- cFields.Width = FieldBox.Width - 350
- IndexBox.Width = Width ' - 350
- cIndexes.Width = IndexBox.Width - 350
- Line1.X2 = IndexBox.Width
- Form_Paint
- End If
- End Sub
- Sub PrintButton_Click ()
- 'this routine simply prints the currently
- 'selected table's definition
- Dim i As Integer
- Dim s As String
- MsgBar "Printing Table Structure", True
- Printer.Print
- Printer.Print
- Printer.Print
- Printer.Print "DataBase: " & gstDBName
- Printer.Print
- Printer.Print
- Printer.Print "Table Definition for " & cTableName
- Printer.Print
- Printer.Print
- Printer.Print "Fields: (Name - Type - Size)"
- Printer.Print String(60, "-")
- For i = 1 To cFields.Rows - 1
- cFields.Row = i
- cFields.Col = 0
- s = cFields & " - "
- cFields.Col = 1
- s = s + cFields & " - "
- cFields.Col = 2
- s = s + cFields
- Printer.Print s
- Next
- Printer.Print
- Printer.Print
- Printer.Print "Index List (Name - Fields - Unique)"
- Printer.Print String(60, "-")
- For i = 1 To cIndexes.Rows - 1
- cIndexes.Row = i
- cIndexes.Col = 0
- s = cIndexes & " - "
- cIndexes.Col = 1
- s = s + cIndexes & " - "
- cIndexes.Col = 2
- s = s + cIndexes
- Printer.Print s
- Next
- Printer.NewPage
- Printer.EndDoc
- MsgBar NULL_STR, False
- End Sub
- Sub RemoveFieldButton_Click ()
- On Error GoTo RFErr
- cFields.Row = cFields.SelStartRow
- cFields.Col = 0
- If Len(cFields) = 0 Then Exit Sub
- If MsgBox("Remove """ & cFields & """ field?", MSGBOX_TYPE) = YES Then
- 'refresh the list of indexes
- If cFields.Rows = 2 Then
- cFields.Col = 0
- cFields = NULL_STR
- cFields.Col = 1
- cFields = NULL_STR
- cFields.Col = 2
- cFields = NULL_STR
- Else
- cFields.RemoveItem cFields.Row
- ResizeFieldGrid
- End If
- End If
- GoTo RFEnd
- RFErr:
- ShowError
- Resume RFEnd
- RFEnd:
- End Sub
- Sub ResizeFieldGrid ()
- If cFields.Rows < 12 Then
- cFields.Height = cFields.Rows * 245
- FieldBox.Height = cFields.Height + 360
- IndexBox.Top = FieldBox.Top + FieldBox.Height + 250
- Height = IndexBox.Top + IndexBox.Height + 500
- End If
- End Sub
-